
'------------------------------------------
' Hands-On 15-1
'------------------------------------------

Sub StartPanel()
    Shell "Control.exe", vbNormalFocus
End Sub


Sub ChangeSettings()
   Dim nrTask
   nrTask = Shell("Control.exe intl.cpl", vbMinimizedFocus)
   Debug.Print nrTask
End Sub


Sub ChangeSettings2()
    Dim nrTask
    Dim iconFile As String
    iconFile = InputBox("Enter the name of the control " & _
              "icon CPL or DLL file:")
    nrTask = Shell("Control.exe " & iconFile, vbMinimizedFocus)
    Debug.Print nrTask
End Sub


'------------------------------------------
' Hands-On 15-2
'------------------------------------------

Sub FindCPLFiles()
    ' The keystrokes are for Windows XP
    Shell "Explorer", vbMaximizedFocus


    ' delay the execution by 5 seconds
    Application.Wait (Now + TimeValue("0:00:05"))

    ' Activate the Search window
    SendKeys "{F3}", True

    ' delay the execution by 5 seconds

    Application.Wait (Now + TimeValue("0:00:05"))

    ' move the pointer to All files and Folder in
    ' Search Companion toolbar

    SendKeys "{Tab}{Tab}{ENTER}", True

    ' type in the search string
    SendKeys "*.cpl", True

    ' move to the Look in drop down box
    SendKeys "{Tab}{Tab}", True

    ' change to the root directory
    SendKeys "C:\", True

    ' execute the Search
    SendKeys "{ENTER}", True

End Sub


'------------------------------------------
' Hands-On 15-3
' No code in this Hands-On.
' Please follow the instructions in the book.
'------------------------------------------


'------------------------------------------
' Hands-On 15-4
'------------------------------------------

Sub InsertLetter()
    Workbooks.Add
    ActiveSheet.Shapes.AddOLEObject Filename:="C:\Ex07_HandsOn\Hello.doc"
End Sub


'------------------------------------------
' Hands-On 15-5
'------------------------------------------

Sub PrintWordDoc()
    Dim objWord As Object
    Set objWord = CreateObject("Word.Application")
    
    With objWord
        .Visible = True
        .Documents.Open "C:\Ex07_HandsOn\LinkOrEmbed.doc"
        .Options.PrintBackground = False
        .ActiveDocument.PrintOut
        .Documents.Close
        .Quit
    End With
    
    Set objWord = Nothing
End Sub

'------------------------------------------
' Hands-On 15-6
' No code in this Hands-On.
' Please follow the instructions in the book.
'------------------------------------------


'------------------------------------------
' Hands-On 15-7
'------------------------------------------

Sub WriteLetter()
    Dim wordAppl As Word.Application
    
    Set wordAppl = CreateObject("Word.Application")
    With wordAppl
        .Visible = True
        .StatusBar = "Creating a new document..."
        .Documents.Add
        .ActiveDocument.Paragraphs(1).Range.InsertBefore "Invitation"
        .StatusBar = "Saving document..."
        .ActiveDocument.SaveAs Filename:="C:\Ex07_ByExample\Invite.doc"
        .StatusBar = "Exiting Word..."
        .Quit
    End With
    Set wordAppl = Nothing
End Sub



'------------------------------------------
' Hands-On 15-8
'------------------------------------------

Sub CenterText()
    Dim wordDoc As Word.Document
    Dim wordAppl As Word.Application
    Dim strDoc As String
    Dim myAppl As String

    On Error GoTo ErrorHandler

    strDoc = "C:\Ex07_ByExample\Invite.doc"
    myAppl = "Word.Application"

    ' first find out whether the specified document exists
    If Not DocExists(strDoc) Then
        MsgBox strDoc & " does not exist." & Chr(13) & Chr(13) _
        & "Please run the WriteLetter procedure to create " & _ 
	strDoc & "."
        Exit Sub
    End If

    ' now check if Word is running
    If Not IsRunning(myAppl) Then
        MsgBox "Word is not running -> will create " & _
        "a new instance of Word. "
        Set wordAppl = CreateObject("Word.Application")
        Set wordDoc = wordAppl.Documents.Open(strDoc)
    Else
        MsgBox "Word is running -> will get the specified document. "
        ' bind the wordDoc variable to a specific Word document
        Set wordDoc = GetObject(strDoc)
    End If
    ' center the 1st paragraph horizontally on page
    With wordDoc.Paragraphs(1).Range
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
    End With
    wordDoc.Application.Quit SaveChanges:=True
    Set wordDoc = Nothing
    Set wordAppl = Nothing
    MsgBox "The document " & strDoc & " was reformatted."
    Exit Sub
ErrorHandler:
    MsgBox Err.Description, vbCritical, "Error: " & Err.Number
End Sub


Function DocExists(ByVal mydoc As String) As Boolean
    On Error Resume Next
    If Dir(mydoc) <> "" Then
        DocExists = True
    Else
        DocExists = False
    End If
End Function


Function IsRunning(ByVal myAppl As String) As Boolean
    Dim applRef As Object
    On Error Resume Next

    Set applRef = GetObject(, myAppl)
    If Err.Number = 429 Then
        IsRunning = False
    Else
        IsRunning = True
    End If
    ' clear the object variable
    Set applRef = Nothing
End Function


'------------------------------------------
' Hands-On 15-9
'------------------------------------------

Sub GetContacts()
    Dim objOut As Outlook.Application
    Dim objNspc As Namespace
    Dim objItem As ContactItem
    Dim r As Integer ' row index
    Dim Headings As Variant
    Dim i As Integer ' array element
    Dim cell As Variant

    r = 2
    Set objOut = New Outlook.Application
    Set objNspc = objOut.GetNamespace("MAPI")

    Headings = Array("Full Name", "Street", "City", _
        "State", "Zip Code", "E-Mail")
    Workbooks.Add
    Sheets(1).Activate
        For Each cell In Range("A1:F1")
            cell.FormulaR1C1 = Headings(i)
            i = i + 1
        Next

    For Each objItem In objNspc.GetDefaultFolder _
        (olFolderContacts).Items
        With ActiveSheet
            .Cells(r, 1).Value = objItem.FullName
            .Cells(r, 2).Value = objItem.BusinessAddress
            .Cells(r, 3).Value = objItem.BusinessAddressCity
            .Cells(r, 4).Value = objItem.BusinessAddressState
            .Cells(r, 5).Value = objItem.BusinessAddressPostalCode
            .Cells(r, 6).Value = objItem.Email1Address
        End With
        r = r + 1
    Next objItem
    Set objItem = Nothing
    Set objNspc = Nothing
    Set objOut = Nothing
    MsgBox "Your contacts have been dumped to Excel."
End Sub

